home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 February: Tool Chest / Dev.CD Feb 95 / Dev.CD Feb 95.toast / Tool Chest / Development Tools & Languages / Dylan Related / Mindy-1.1 (sources only) / mindy-1.1 / interp / table.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-06-28  |  7.7 KB  |  273 lines  |  [TEXT/ttxt]
  1. /**********************************************************************\
  2. *
  3. *  Copyright (c) 1994  Carnegie Mellon University
  4. *  All rights reserved.
  5. *  
  6. *  Use and copying of this software and preparation of derivative
  7. *  works based on this software are permitted, including commercial
  8. *  use, provided that the following conditions are observed:
  9. *  
  10. *  1. This copyright notice must be retained in full on any copies
  11. *     and on appropriate parts of any derivative works.
  12. *  2. Documentation (paper or online) accompanying any system that
  13. *     incorporates this software, or any part of it, must acknowledge
  14. *     the contribution of the Gwydion Project at Carnegie Mellon
  15. *     University.
  16. *  
  17. *  This software is made available "as is".  Neither the authors nor
  18. *  Carnegie Mellon University make any warranty about the software,
  19. *  its performance, or its conformity to any specification.
  20. *  
  21. *  Bug reports, questions, comments, and suggestions should be sent by
  22. *  E-mail to the Internet address "gwydion-bugs@cs.cmu.edu".
  23. *
  24. ***********************************************************************
  25. *
  26. * $Header: table.c,v 1.10 94/06/27 16:32:34 wlott Exp $
  27. *
  28. * This file implements support for <table>. Specifically, that means
  29. * writing object-hash and merge-hash-codes, and defining
  30. * $permanent-hash-state. As an extension for <equal-table> and 
  31. * <value-table>, float-hash has been included for hashing floating point
  32. * numbers without using object-hash.
  33. *
  34. \**********************************************************************/
  35.  
  36. #include <stdio.h>
  37. #include <limits.h>
  38.  
  39. #include "mindy.h"
  40. #include "thread.h"
  41. #include "func.h"
  42. #include "def.h"
  43. #include "list.h"
  44. #include "bool.h"
  45. #include "num.h"
  46. #include "obj.h"
  47. #include "sym.h"
  48. #include "gc.h"
  49. #include "class.h"
  50. #include "print.h"
  51. #include "table.h"
  52.  
  53. struct hash_state {
  54.     obj_t class;
  55. };
  56.  
  57. static obj_t obj_HashStateClass = NULL;
  58. static obj_t permanent_state = NULL;
  59. static obj_t valid_state = NULL;
  60.  
  61. /* object-hash returns $permanent-hash-state for all <number>s implemented
  62.  * in Mindy. Basically, it's implemented by a series of if's: fixnum?
  63.  * single_float? double_float? extended_float? If any of those, return an
  64.  * appropriate value along with $permanent-hash-state. Otherwise, hash
  65.  * the pointer and return a non-permanent hash state.
  66.  *
  67.  * Floats are hashed in a non-portable way: By using & on the C
  68.  * representation of the floating point number (along with some type
  69.  * coercision to keep the warnings to a minimum).
  70.  * (see also float-hash)
  71.  */
  72.  
  73. static void dylan_object_hash(struct thread *thread, int nargs)
  74. {
  75.     obj_t *old_sp = thread->sp - 2;
  76.     obj_t object = old_sp[1];
  77.     obj_t class;
  78.  
  79.     assert(nargs == 1);
  80.  
  81.     if (obj_is_fixnum(object)) {
  82.         old_sp[0] = (obj_t)(((unsigned long)MAX_FIXNUM)
  83.                     & ((unsigned long)object));
  84.     old_sp[1] = permanent_state;
  85.     }
  86.     else {
  87.         class = obj_ptr(struct object *, object)->class;
  88.         if (class == obj_SingleFloatClass) {
  89.             old_sp[0] = (obj_t)(((unsigned long)MAX_FIXNUM)
  90.                 & (*((int *)(&single_value(object)))));
  91.                 /* Pretend the float is really an
  92.                    integer so we can get at its bits */
  93.         old_sp[1] = permanent_state;
  94.     }
  95.         else if (class == obj_DoubleFloatClass) {
  96.             old_sp[0] = (obj_t)(((unsigned long)MAX_FIXNUM)
  97.                 & (*((int *)(&double_value(object)))));
  98.                 /* Pretend the float is really an
  99.                    integer so we can get at its bits */
  100.         old_sp[1] = permanent_state;
  101.     }
  102.         else if (class == obj_ExtendedFloatClass) {
  103.             old_sp[0] = (obj_t)(((unsigned long)MAX_FIXNUM)
  104.                 & (*((int *)(&extended_value(object)))));
  105.                 /* Pretend the float is really an
  106.                    integer so we can get at its bits */
  107.         old_sp[1] = permanent_state;
  108.     }
  109.     else {            /* Hash the pointer itself */
  110.             old_sp[0] = (obj_t)(((unsigned long)MAX_FIXNUM)
  111.                        & ((unsigned long)object));
  112.  
  113.         if (valid_state == obj_False)
  114.            valid_state = alloc(obj_HashStateClass, 
  115.                                    sizeof(struct hash_state));
  116.         old_sp[1] = valid_state;
  117.     }
  118.     }
  119.  
  120.     do_return(thread, old_sp, old_sp);
  121. }
  122.  
  123. static obj_t dylan_state_valid_p(obj_t state)
  124. {
  125.     if (state == permanent_state || state == valid_state)
  126.     return obj_True;
  127.     else
  128.     return obj_False;
  129. }
  130.  
  131. static void dylan_merge_hash_codes(obj_t self, struct thread *thread,
  132.                    obj_t *args)
  133. {
  134.     unsigned long id1 = fixnum_value(args[0]);
  135.     obj_t state1 = args[1];
  136.     unsigned long id2 = fixnum_value(args[2]);
  137.     obj_t state2 = args[3];
  138.     obj_t ordered = args[4];
  139.     obj_t *old_sp = args-1;
  140.  
  141.     if (ordered != obj_False)
  142.     id2 = (id2 << 5) | (id2 >> (sizeof(long)*CHAR_BIT-5));
  143.     old_sp[0] = make_fixnum(id1 ^ id2);
  144.  
  145.     if (state1 == permanent_state)
  146.     old_sp[1] = state2;
  147.     else if (state2 == permanent_state)
  148.     old_sp[1] = state1;
  149.     else if (state1 == valid_state)
  150.     old_sp[1] = state2;
  151.     else
  152.     old_sp[1] = state1;
  153.  
  154.     thread->sp = old_sp + 2;
  155.     do_return(thread, old_sp, old_sp);
  156. }
  157.  
  158. static void dylan_float_hash(struct thread *thread, int nargs)
  159. {
  160.     obj_t *old_sp = thread->sp - 2;
  161.     obj_t object = old_sp[1];
  162.     obj_t class = obj_ptr(struct object *, object)->class;
  163.     long double value;
  164.  
  165.     assert(nargs == 1);
  166.  
  167.     if (class == obj_SingleFloatClass)
  168.     value = single_value(object);
  169.     else if (class == obj_DoubleFloatClass)
  170.     value = double_value(object);
  171.     else if (class == obj_ExtendedFloatClass)
  172.     value = extended_value(object);
  173.  
  174.     else 
  175.     lose("I can't float-hash that!");
  176.  
  177.     old_sp[0] = (obj_t)(((unsigned long)MAX_FIXNUM) & (*((int *)(&value))));
  178.             /* Pretend the float is really an integer so we 
  179.            can get at its bits */
  180.  
  181.     old_sp[1] = permanent_state;
  182.     do_return(thread, old_sp, old_sp);
  183. }
  184.  
  185.  
  186.  
  187. /* Printing routine. */
  188.  
  189. static void print_state(obj_t state)
  190. {
  191.     if (state == permanent_state)
  192.     printf("{permanent hash state}");
  193.     else if (state == valid_state)
  194.     printf("{valid hash state}");
  195.     else
  196.     printf("{invalid hash state}");
  197. }
  198.  
  199.  
  200. /* GC routines. */
  201.  
  202. static int scav_state(struct object *o)
  203. {
  204.     return sizeof(struct hash_state);
  205. }
  206.  
  207. static obj_t trans_state(obj_t state)
  208. {
  209.     return transport(state, sizeof(struct hash_state));
  210. }
  211.  
  212. void scavenge_table_roots(void)
  213. {
  214.     scavenge(&obj_HashStateClass);
  215.     scavenge(&permanent_state);
  216.     valid_state = NULL;
  217. }    
  218.  
  219. void table_gc_hook(void)
  220. {
  221.     valid_state = obj_False;
  222. }
  223.  
  224.  
  225. /* Init routines. */
  226.  
  227. void make_table_classes(void)
  228. {
  229.     obj_HashStateClass = make_builtin_class(scav_state, trans_state);
  230. }
  231.  
  232. void init_table_classes(void)
  233. {
  234.     init_builtin_class(obj_HashStateClass, "<hash-state>",
  235.                obj_ObjectClass, NULL);
  236.     def_printer(obj_HashStateClass, print_state);
  237. }
  238.  
  239. void init_table_functions(void)
  240. {
  241.     define_constant("object-hash",
  242.             make_raw_function("object-hash", 1, FALSE, obj_False,
  243.                       FALSE,
  244.                       list2(obj_IntegerClass,
  245.                         obj_HashStateClass),
  246.                       obj_False, dylan_object_hash));
  247.     define_constant("float-hash",
  248.             make_raw_function("float-hash", 1, FALSE, obj_False,
  249.                       FALSE,
  250.                       list2(obj_IntegerClass,
  251.                         obj_HashStateClass),
  252.                       obj_False, dylan_float_hash));
  253.     define_function("state-valid?", list1(obj_HashStateClass), FALSE,
  254.             obj_False, FALSE, obj_BooleanClass, dylan_state_valid_p);
  255.     define_constant("merge-hash-codes",
  256.             make_raw_method("merge-hash-codes",
  257.                     listn(4, obj_IntegerClass,
  258.                       obj_HashStateClass,
  259.                       obj_IntegerClass,
  260.                       obj_HashStateClass),
  261.                     FALSE,
  262.                     list1(pair(symbol("ordered"), obj_False)),
  263.                     FALSE, 
  264.                     list2(obj_IntegerClass,
  265.                       obj_HashStateClass),
  266.                     obj_False, dylan_merge_hash_codes));
  267.  
  268.     permanent_state = alloc(obj_HashStateClass, sizeof(struct hash_state));
  269.     define_constant("$permanent-hash-state", permanent_state);
  270.  
  271.     valid_state = obj_False;
  272. }
  273.